Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Applications/P4⁄Mac 2.0d4/Mac source 2.0/block1.p

Text File | 1996-09-28 | 24.5 KB | 1,107 lines | [TEXT/PJMM]

{P4/Mac port by Ingemar Ragnemalm 1994-1996}

unit block1;

interface
    uses
        Messages, pcom1;

{procedures that used to be sub-procedures to block.}
    var
        lsy: p_symbol;
        test: boolean;
{Parameters to block:}
{fsys: setofsys;}
{fsy: symbol;}
{fprocp: ctp;}

    procedure skip (fsys: setofsys);
    procedure Bconstant (fsys: setofsys; var fsp: stp; var fvalu: valu);
    function equalbounds (fsp1, fsp2: stp): boolean;
    function comptypes (fsp1, fsp2: stp): boolean;
    function isString (fsp: stp): boolean;
    procedure typ (fsys: setofsys; var fsp: stp; var fsize: addrrange);
    procedure labeldeclaration (fsys: setofsys); {FIX!!!}
    procedure constdeclaration (fsys: setofsys); {FIX!!!}
    procedure typedeclaration (fsys: setofsys); {FIX!!!}
    procedure vardeclaration (fsys: setofsys); {FIX!!!}

implementation

    procedure skip (fsys: setofsys);
      (*skip input string until relevant symbol found*)
    begin
        if not eof(input) then
            begin
                while not (sy in fsys) and (not eof(input)) do
                    insymbol;
                if not (sy in fsys) then
                    insymbol
            end
    end; (*skip*)

    procedure Bconstant (fsys: setofsys; var fsp: stp; var fvalu: valu);
        var
            lsp: stp;
            lcp: ctp;
            sign: (none, pos, neg);
            lvp: csp;
            i: 2..strglgth;
    begin
        lsp := nil;
        fvalu.ival := 0;
        if not (sy in constbegsys) then
            begin
                error(50);
                skip(fsys + constbegsys)
            end;
        if sy in constbegsys then
            begin
                if sy = stringconst then
                    begin
                        if lgth = 1 then
                            lsp := charptr
                        else
                            begin
                                new(lsp, arrays);
                                with lsp^ do
                                    begin
                                        aeltype := charptr;
                                        inxtype := nil;
                                        size := lgth * charsize;
                                        form := arrays
                                    end
                            end;
                        fvalu := val;
                        insymbol
                    end
                else
                    begin
                        sign := none;
                        if (sy = addop) and (op in [plus, minus]) then
                            begin
                                if op = plus then
                                    sign := pos
                                else
                                    sign := neg;
                                insymbol
                            end;
                        if sy = ident then
                            begin
                                searchid([konst], lcp);
                                with lcp^ do
                                    begin
                                        lsp := idtype;
                                        fvalu := values
                                    end;
                                if sign <> none then
                                    if lsp = intptr then
                                        begin
                                            if sign = neg then
                                                fvalu.ival := -fvalu.ival
                                        end
                                    else if lsp = realptr then
                                        begin
                                            if sign = neg then
                                                begin
                                                    new(lvp, reel);
                                                    if fvalu.valp^.rval[1] = '-' then
                                                        lvp^.rval[1] := '+'
                                                    else
                                                        lvp^.rval[1] := '-';
                                                    for i := 2 to strglgth do
                                                        lvp^.rval[i] := fvalu.valp^.rval[i];
                                                    fvalu.valp := lvp;
                                                end
                                        end
                                    else
                                        error(105);
                                insymbol;
                            end
                        else if sy = intconst then
                            begin
                                if sign = neg then
                                    val.ival := -val.ival;
                                lsp := intptr;
                                fvalu := val;
                                insymbol
                            end
                        else if sy = realconst then
                            begin
                                if sign = neg then
                                    val.valp^.rval[1] := '-';
                                lsp := realptr;
                                fvalu := val;
                                insymbol
                            end
                        else
                            begin
                                error(106);
                                skip(fsys)
                            end
                    end;
                if not (sy in fsys) then
                    begin
                        error(6);
                        skip(fsys)
                    end
            end;
        fsp := lsp
    end; (*Bconstant*)

    function equalbounds (fsp1, fsp2: stp): boolean;
        var
            lmin1, lmin2, lmax1, lmax2: integer;
    begin
        if (fsp1 = nil) or (fsp2 = nil) then
            equalbounds := true
        else
            begin
                getbounds(fsp1, lmin1, lmax1);
                getbounds(fsp2, lmin2, lmax2);
                equalbounds := (lmin1 = lmin2) and (lmax1 = lmax2)
            end
    end; (*equalbounds*)

    function comptypes (fsp1, fsp2: stp): boolean;
      (*decide whether structures pointed at by fsp1 and fsp2 are compatible*)
        var
            nxt1, nxt2: ctp;
            comp: boolean;
            ltestp1, ltestp2: testp;
    begin
        if fsp1 = fsp2 then
            comptypes := true
        else if (fsp1 <> nil) and (fsp2 <> nil) then
            if fsp1^.form = fsp2^.form then
                case fsp1^.form of
                    scalar:
                        comptypes := false;
        (* identical scalars declared on different levels are}
{         not recognized to be compatible*)
                    subrange:
                        comptypes := comptypes(fsp1^.rangetype, fsp2^.rangetype);
                    pointer:
                        begin
                            comp := false;
                            ltestp1 := globtestp;
                            ltestp2 := globtestp;
                            while ltestp1 <> nil do
                                with ltestp1^ do
                                    begin
                                        if (elt1 = fsp1^.eltype) and (elt2 = fsp2^.eltype) then
                                            comp := true;
                                        ltestp1 := lasttestp
                                    end;
                            if not comp then
                                begin
                                    new(ltestp1);
                                    with ltestp1^ do
                                        begin
                                            elt1 := fsp1^.eltype;
                                            elt2 := fsp2^.eltype;
                                            lasttestp := globtestp
                                        end;
                                    globtestp := ltestp1;
                                    comp := comptypes(fsp1^.eltype, fsp2^.eltype)
                                end;
                            comptypes := comp;
                            globtestp := ltestp2
                        end;
                    power:
                        comptypes := comptypes(fsp1^.elset, fsp2^.elset);
                    arrays:
                        begin
                            comp := comptypes(fsp1^.aeltype, fsp2^.aeltype) and comptypes(fsp1^.inxtype, fsp2^.inxtype);
                            comptypes := comp and (fsp1^.size = fsp2^.size) and equalbounds(fsp1^.inxtype, fsp2^.inxtype)
                        end;
                    records:
                        begin
                            nxt1 := fsp1^.fstfld;
                            nxt2 := fsp2^.fstfld;
                            comp := true;
                            while (nxt1 <> nil) and (nxt2 <> nil) do
                                begin
                                    comp := comp and comptypes(nxt1^.idtype, nxt2^.idtype);
                                    nxt1 := nxt1^.next;
                                    nxt2 := nxt2^.next
                                end;
                            comptypes := comp and (nxt1 = nil) and (nxt2 = nil) and (fsp1^.recvar = nil) and (fsp2^.recvar = nil)
                        end;
        (*identical records are recognized to be compatible}
{         iff no variants occur*)
                    files:
                        comptypes := comptypes(fsp1^.filtype, fsp2^.filtype)
                end (*case*)
            else (*fsp1^.form <> fsp2^.form*)
                if fsp1^.form = subrange then
                    comptypes := comptypes(fsp1^.rangetype, fsp2)
                else if fsp2^.form = subrange then
                    comptypes := comptypes(fsp1, fsp2^.rangetype)
                else
                    comptypes := false
        else
            comptypes := true
    end; (*comptypes*)

{"isString" used to be "string", which is reserved in Think Pascal.}
{Is isString a proper name?}
{/Ingemar}
    function isString (fsp: stp): boolean;
    begin
        isString := false;
        if fsp <> nil then
            if fsp^.form = arrays then
                if comptypes(fsp^.aeltype, charptr) then
                    isString := true
    end; (*isString*)

    procedure typ (fsys: setofsys; var fsp: stp; var fsize: addrrange);
        var
            lsp, lsp1, lsp2: stp;
            oldtop: disprange;
            lcp: ctp;
            lsize, displ: addrrange;
            lmin, lmax: integer;

        procedure simpletype (fsys: setofsys; var fsp: stp; var fsize: addrrange);
            var
                lsp, lsp1: stp;
                lcp, lcp1: ctp;
                ttop: disprange;
                lcnt: integer;
                lvalu: valu;
        begin
            fsize := 1;
            if not (sy in simptypebegsys) then
                begin
                    error(1);
                    skip(fsys + simptypebegsys)
                end;
            if sy in simptypebegsys then
                begin
                    if sy = lparent then
                        begin
                            ttop := top;   (*decl. consts local to innermost block*)
                            while display[top].occur <> blck do
                                top := top - 1;
                            new(lsp, scalar, declared);
                            with lsp^ do
                                begin
                                    size := intsize;
                                    form := scalar;
                                    scalkind := declared
                                end;
                            lcp1 := nil;
                            lcnt := 0;
                            repeat
                                insymbol;
                                if sy = ident then
                                    begin
                                        new(lcp, konst);
                                        with lcp^ do
                                            begin
                                                name := id;
                                                idtype := lsp;
                                                next := lcp1;
                                                values.ival := lcnt;
                                                klass := konst
                                            end;
                                        enterid(lcp);
                                        lcnt := lcnt + 1;
                                        lcp1 := lcp;
                                        insymbol
                                    end
                                else
                                    error(2);
                                if not (sy in fsys + [comma, rparent]) then
                                    begin
                                        error(6);
                                        skip(fsys + [comma, rparent])
                                    end
                            until sy <> comma;
                            lsp^.fconst := lcp1;
                            top := ttop;
                            if sy = rparent then
                                insymbol
                            else
                                error(4)
                        end
                    else
                        begin
                            if sy = ident then
                                begin
                                    searchid([types, konst], lcp);
                                    insymbol;
                                    if lcp^.klass = konst then
                                        begin
                                            new(lsp, subrange);
                                            with lsp^, lcp^ do
                                                begin
                                                    rangetype := idtype;
                                                    form := subrange;
                                                    if isString(rangetype) then
                                                        begin
                                                            error(148);
                                                            rangetype := nil
                                                        end;
                                                    min := values;
                                                    size := intsize
                                                end;
                                            if sy = colon then
                                                insymbol
                                            else
                                                error(5);
                                            Bconstant(fsys, lsp1, lvalu);
                                            lsp^.max := lvalu;
                                            if lsp^.rangetype <> lsp1 then
                                                error(107)
                                        end
                                    else
                                        begin
                                            lsp := lcp^.idtype;
                                            if lsp <> nil then
                                                fsize := lsp^.size
                                        end
                                end (*sy = ident*)
                            else
                                begin
                                    new(lsp, subrange);
                                    lsp^.form := subrange;
                                    Bconstant(fsys + [colon], lsp1, lvalu);
                                    if isString(lsp1) then
                                        begin
                                            error(148);
                                            lsp1 := nil
                                        end;
                                    with lsp^ do
                                        begin
                                            rangetype := lsp1;
                                            min := lvalu;
                                            size := intsize
                                        end;
                                    if sy = colon then
                                        insymbol
                                    else
                                        error(5);
                                    Bconstant(fsys, lsp1, lvalu);
                                    lsp^.max := lvalu;
                                    if lsp^.rangetype <> lsp1 then
                                        error(107)
                                end;
                            if lsp <> nil then
                                with lsp^ do
                                    if form = subrange then
                                        if rangetype <> nil then
                                            if rangetype = realptr then
                                                error(399)
                                            else if min.ival > max.ival then
                                                error(102)
                        end;
                    fsp := lsp;
                    if not (sy in fsys) then
                        begin
                            error(6);
                            skip(fsys)
                        end
                end
            else
                fsp := nil
        end; (*simpletype*)

        procedure fieldlist (fsys: setofsys; var frecvar: stp);
            var
                lcp, lcp1, nxt, nxt1: ctp;
                lsp, lsp1, lsp2, lsp3, lsp4: stp;
                minsize, maxsize, lsize: addrrange;
                lvalu: valu;
        begin
            nxt1 := nil;
            lsp := nil;
            if not (sy in (fsys + [ident, casesy])) then
                begin
                    error(19);
                    skip(fsys + [ident, casesy])
                end;
            while sy = ident do
                begin
                    nxt := nxt1;
                    repeat
                        if sy = ident then
                            begin
                                new(lcp, field);
                                with lcp^ do
                                    begin
                                        name := id;
                                        idtype := nil;
                                        next := nxt;
                                        klass := field
                                    end;
                                nxt := lcp;
                                enterid(lcp);
                                insymbol
                            end
                        else
                            error(2);
                        if not (sy in [comma, colon]) then
                            begin
                                error(6);
                                skip(fsys + [comma, colon, semicolon, casesy])
                            end;
                        test := sy <> comma;
                        if not test then
                            insymbol
                    until test;
                    if sy = colon then
                        insymbol
                    else
                        error(5);
                    typ(fsys + [casesy, semicolon], lsp, lsize);
                    while nxt <> nxt1 do
                        with nxt^ do
                            begin
                                align(lsp, displ);
                                idtype := lsp;
                                fldaddr := displ;
                                nxt := next;
                                displ := displ + lsize
                            end;
                    nxt1 := lcp;
                    while sy = semicolon do
                        begin
                            insymbol;
                            if not (sy in fsys + [ident, casesy, semicolon]) then
                                begin
                                    error(19);
                                    skip(fsys + [ident, casesy])
                                end
                        end
                end; (*while*)
            nxt := nil;
            while nxt1 <> nil do
                with nxt1^ do
                    begin
                        lcp := next;
                        next := nxt;
                        nxt := nxt1;
                        nxt1 := lcp
                    end;
            if sy = casesy then
                begin
                    new(lsp, tagfld);
                    with lsp^ do
                        begin
                            tagfieldp := nil;
                            fstvar := nil;
                            form := tagfld
                        end;
                    frecvar := lsp;
                    insymbol;
                    if sy = ident then
                        begin
                            new(lcp, field);
                            with lcp^ do
                                begin
                                    name := id;
                                    idtype := nil;
                                    klass := field;
                                    next := nil;
                                    fldaddr := displ
                                end;
                            enterid(lcp);
                            insymbol;
                            if sy = colon then
                                insymbol
                            else
                                error(5);
                            if sy = ident then
                                begin
                                    searchid([types], lcp1);
                                    lsp1 := lcp1^.idtype;
                                    if lsp1 <> nil then
                                        begin
                                            align(lsp1, displ);
                                            lcp^.fldaddr := displ;
                                            displ := displ + lsp1^.size;
                                            if (lsp1^.form <= subrange) or isString(lsp1) then
                                                begin
                                                    if comptypes(realptr, lsp1) then
                                                        error(109)
                                                    else if isString(lsp1) then
                                                        error(399);
                                                    lcp^.idtype := lsp1;
                                                    lsp^.tagfieldp := lcp;
                                                end
                                            else
                                                error(110);
                                        end;
                                    insymbol;
                                end
                            else
                                begin
                                    error(2);
                                    skip(fsys + [ofsy, lparent])
                                end
                        end
                    else
                        begin
                            error(2);
                            skip(fsys + [ofsy, lparent])
                        end;
                    lsp^.size := displ;
                    if sy = ofsy then
                        insymbol
                    else
                        error(8);
                    lsp1 := nil;
                    minsize := displ;
                    maxsize := displ;
                    repeat
                        lsp2 := nil;
                        if not (sy in fsys + [semicolon]) then
                            begin
                                repeat
                                    Bconstant(fsys + [comma, colon, lparent], lsp3, lvalu);
                                    if lsp^.tagfieldp <> nil then
                                        if not comptypes(lsp^.tagfieldp^.idtype, lsp3) then
                                            error(111);
                                    new(lsp3, variant);
                                    with lsp3^ do
                                        begin
                                            nxtvar := lsp1;
                                            subvar := lsp2;
                                            varval := lvalu;
                                            form := variant
                                        end;
                                    lsp4 := lsp1;
                                    while lsp4 <> nil do
                                        with lsp4^ do
                                            begin
                                                if varval.ival = lvalu.ival then
                                                    error(178);
                                                lsp4 := nxtvar
                                            end;
                                    lsp1 := lsp3;
                                    lsp2 := lsp3;
                                    test := sy <> comma;
                                    if not test then
                                        insymbol
                                until test;
                                if sy = colon then
                                    insymbol
                                else
                                    error(5);
                                if sy = lparent then
                                    insymbol
                                else
                                    error(9);
                                fieldlist(fsys + [rparent, semicolon], lsp2);
                                if displ > maxsize then
                                    maxsize := displ;
                                while lsp3 <> nil do
                                    begin
                                        lsp4 := lsp3^.subvar;
                                        lsp3^.subvar := lsp2;
                                        lsp3^.size := displ;
                                        lsp3 := lsp4
                                    end;
                                if sy = rparent then
                                    begin
                                        insymbol;
                                        if not (sy in fsys + [semicolon]) then
                                            begin
                                                error(6);
                                                skip(fsys + [semicolon])
                                            end
                                    end
                                else
                                    error(4);
                            end;
                        test := sy <> semicolon;
                        if not test then
                            begin
                                displ := minsize;
                                insymbol
                            end
                    until test;
                    displ := maxsize;
                    lsp^.fstvar := lsp1;
                end
            else
                frecvar := nil
        end; (*fieldlist*)

    begin (*typ*)
        if not (sy in typebegsys) then
            begin
                error(10);
                skip(fsys + typebegsys)
            end;
        if sy in typebegsys then
            begin
                if sy in simptypebegsys then
                    simpletype(fsys, fsp, fsize)
                else
    (*^*)
                    if sy = arrow then
                        begin
                            new(lsp, pointer);
                            fsp := lsp;
                            with lsp^ do
                                begin
                                    eltype := nil;
                                    size := ptrsize;
                                    form := pointer
                                end;
                            insymbol;
                            if sy = ident then
                                begin
                                    prterr := false; (*no error if search not successful*)
                                    searchid([types], lcp);
                                    prterr := true;
                                    if lcp = nil then   (*forward referenced type id*)
                                        begin
                                            new(lcp, types);
                                            with lcp^ do
                                                begin
                                                    name := id;
                                                    idtype := lsp;
                                                    next := fwptr;
                                                    klass := types
                                                end;
                                            fwptr := lcp
                                        end
                                    else
                                        begin
                                            if lcp^.idtype <> nil then
                                                if lcp^.idtype^.form = files then
                                                    error(108)
                                                else
                                                    lsp^.eltype := lcp^.idtype
                                        end;
                                    insymbol;
                                end
                            else
                                error(2);
                        end
                    else
                        begin
                            if sy = packedsy then
                                begin
                                    insymbol;
                                    if not (sy in typedels) then
                                        begin
                                            error(10);
                                            skip(fsys + typedels)
                                        end
                                end;
    (*array*)
                            if sy = arraysy then
                                begin
                                    insymbol;
                                    if sy = lbrack then
                                        insymbol
                                    else
                                        error(11);
                                    lsp1 := nil;
                                    repeat
                                        new(lsp, arrays);
                                        with lsp^ do
                                            begin
                                                aeltype := lsp1;
                                                inxtype := nil;
                                                form := arrays
                                            end;
                                        lsp1 := lsp;
                                        simpletype(fsys + [comma, rbrack, ofsy], lsp2, lsize);
                                        lsp1^.size := lsize;
                                        if lsp2 <> nil then
                                            if lsp2^.form <= subrange then
                                                begin
                                                    if lsp2 = realptr then
                                                        begin
                                                            error(109);
                                                            lsp2 := nil
                                                        end
                                                    else if lsp2 = intptr then
                                                        begin
                                                            error(149);
                                                            lsp2 := nil
                                                        end;
                                                    lsp^.inxtype := lsp2
                                                end
                                            else
                                                begin
                                                    error(113);
                                                    lsp2 := nil
                                                end;
                                        test := sy <> comma;
                                        if not test then
                                            insymbol
                                    until test;
                                    if sy = rbrack then
                                        insymbol
                                    else
                                        error(12);
                                    if sy = ofsy then
                                        insymbol
                                    else
                                        error(8);
                                    typ(fsys, lsp, lsize);
                                    repeat
                                        with lsp1^ do
                                            begin
                                                lsp2 := aeltype;
                                                aeltype := lsp;
                                                if inxtype <> nil then
                                                    begin
                                                        getbounds(inxtype, lmin, lmax);
                                                        align(lsp, lsize);
                                                        lsize := lsize * (lmax - lmin + 1);
                                                        size := lsize
                                                    end
                                            end;
                                        lsp := lsp1;
                                        lsp1 := lsp2
                                    until lsp1 = nil
                                end
                            else
    (*record*)
                                if sy = recordsy then
                                    begin
                                        insymbol;
                                        oldtop := top;
                                        if top < displimit then
                                            begin
                                                top := top + 1;
                                                with display[top] do
                                                    begin
                                                        fname := nil;
                                                        flabel := nil;
                                                        occur := rec
                                                    end
                                            end
                                        else
                                            error(250);
                                        displ := 0;
                                        fieldlist(fsys - [semicolon] + [endsy], lsp1);
                                        new(lsp, records);
                                        with lsp^ do
                                            begin
                                                fstfld := display[top].fname;
                                                recvar := lsp1;
                                                size := displ;
                                                form := records
                                            end;
                                        top := oldtop;
                                        if sy = endsy then
                                            insymbol
                                        else
                                            error(13)
                                    end
                                else
    (*set*)
                                    if sy = setsy then
                                        begin
                                            insymbol;
                                            if sy = ofsy then
                                                insymbol
                                            else
                                                error(8);
                                            simpletype(fsys, lsp1, lsize);
                                            if lsp1 <> nil then
                                                if lsp1^.form > subrange then
                                                    begin
                                                        error(115);
                                                        lsp1 := nil
                                                    end
                                                else if lsp1 = realptr then
                                                    begin
                                                        error(114);
                                                        lsp1 := nil
                                                    end
                                                else if lsp1 = intptr then
                                                    begin
                                                        error(169);
                                                        lsp1 := nil
                                                    end
                                                else
                                                    begin
                                                        getbounds(lsp1, lmin, lmax);
                                                        if (lmin < setlow) or (lmax > sethigh) then
                                                            error(169);
                                                    end;
                                            new(lsp, power);
                                            with lsp^ do
                                                begin
                                                    elset := lsp1;
                                                    size := setsize;
                                                    form := power
                                                end;
                                        end
                                    else
    (*file*)
                                        if sy = filesy then
                                            begin
                                                insymbol;
                                                error(399);
                                                skip(fsys);
                                                lsp := nil
                                            end;
                            fsp := lsp
                        end;
                if not (sy in fsys) then
                    begin
                        error(6);
                        skip(fsys)
                    end
            end
        else
            fsp := nil;
        if fsp = nil then
            fsize := 1
        else
            fsize := fsp^.size
    end; (*typ*)

    procedure labeldeclaration (fsys: setofsys); {FIX!!!}
        var
            llp: lbp;
            redef: boolean;
            lbname: integer;
    begin
        repeat
            if sy = intconst then
                with display[top] do
                    begin
                        llp := flabel;
                        redef := false;
                        while (llp <> nil) and not redef do
                            if llp^.labval <> val.ival then
                                llp := llp^.nextlab
                            else
                                begin
                                    redef := true;
                                    error(166)
                                end;
                        if not redef then
                            begin
                                new(llp);
                                with llp^ do
                                    begin
                                        labval := val.ival;
                                        genlabel(lbname);
                                        defined := false;
                                        nextlab := flabel;
                                        labname := lbname
                                    end;
                                flabel := llp
                            end;
                        insymbol
                    end
            else
                error(15);
            if not (sy in fsys + [comma, semicolon]) then
                begin
                    error(6);
                    skip(fsys + [comma, semicolon])
                end;
            test := sy <> comma;
            if not test then
                insymbol
        until test;
        if sy = semicolon then
            insymbol
        else
            error(14)
    end; (* labeldeclaration *)

    procedure constdeclaration (fsys: setofsys); {FIX!!!}
        var
            lcp: ctp;
            lsp: stp;
            lvalu: valu;
    begin
        if sy <> ident then
            begin
                error(2);
                skip(fsys + [ident])
            end;
        while sy = ident do
            begin
                new(lcp, konst);
                with lcp^ do
                    begin
                        name := id;
                        idtype := nil;
                        next := nil;
                        klass := konst
                    end;
                insymbol;
                if (sy = relop) and (op = eqop) then
                    insymbol
                else
                    error(16);
                Bconstant(fsys + [semicolon], lsp, lvalu);
                enterid(lcp);
                lcp^.idtype := lsp;
                lcp^.values := lvalu;
                if sy = semicolon then
                    begin
                        insymbol;
                        if not (sy in fsys + [ident]) then
                            begin
                                error(6);
                                skip(fsys + [ident])
                            end
                    end
                else
                    error(14)
            end
    end; (*constdeclaration*)

    procedure typedeclaration (fsys: setofsys); {FIX!!!}
        var
            lcp, lcp1, lcp2: ctp;
            lsp: stp;
            lsize: addrrange;
    begin
        if sy <> ident then
            begin
                error(2);
                skip(fsys + [ident])
            end;
        while sy = ident do
            begin
                new(lcp, types);
                with lcp^ do
                    begin
                        name := id;
                        idtype := nil;
                        klass := types
                    end;
                insymbol;
                if (sy = relop) and (op = eqop) then
                    insymbol
                else
                    error(16);
                typ(fsys + [semicolon], lsp, lsize);
                enterid(lcp);
                lcp^.idtype := lsp;
      (*has any forward reference been satisfied:*)
                lcp1 := fwptr;
                while lcp1 <> nil do
                    begin
                        if lcp1^.name = lcp^.name then
                            begin
                                lcp1^.idtype^.eltype := lcp^.idtype;
                                if lcp1 <> fwptr then
                                    lcp2^.next := lcp1^.next
                                else
                                    fwptr := lcp1^.next;
                            end
                        else
                            lcp2 := lcp1;
                        lcp1 := lcp1^.next
                    end;
                if sy = semicolon then
                    begin
                        insymbol;
                        if not (sy in fsys + [ident]) then
                            begin
                                error(6);
                                skip(fsys + [ident])
                            end
                    end
                else
                    error(14)
            end;
        if fwptr <> nil then
            begin
                error(117);
                WriteLnMessage;
                repeat
                    WriteMessageLine(StringOf(' type-id ', fwptr^.name));
                    fwptr := fwptr^.next
                until fwptr = nil;
                if not eol then
                    WriteMessage(StringOf(' ' : chcnt + 16))
            end
    end; (*typedeclaration*)

    procedure vardeclaration (fsys: setofsys); {FIX!!!}
        var
            lcp, nxt: ctp;
            lsp: stp;
            lsize: addrrange;
    begin
        nxt := nil;
        repeat
            repeat
                if sy = ident then
                    begin
                        new(lcp, vars);
                        with lcp^ do
                            begin
                                name := id;
                                next := nxt;
                                klass := vars;
                                idtype := nil;
                                vkind := actual;
                                vlev := level
                            end;
                        enterid(lcp);
                        nxt := lcp;
                        insymbol;
                    end
                else
                    error(2);
                if not (sy in fsys + [comma, colon] + typedels) then
                    begin
                        error(6);
                        skip(fsys + [comma, colon, semicolon] + typedels)
                    end;
                test := sy <> comma;
                if not test then
                    insymbol
            until test;
            if sy = colon then
                insymbol
            else
                error(5);
            typ(fsys + [semicolon] + typedels, lsp, lsize);
            while nxt <> nil do
                with nxt^ do
                    begin
                        align(lsp, lc);
                        idtype := lsp;
                        vaddr := lc;
                        lc := lc + lsize;
                        nxt := next
                    end;
            if sy = semicolon then
                begin
                    insymbol;
                    if not (sy in fsys + [ident]) then
                        begin
                            error(6);
                            skip(fsys + [ident])
                        end
                end
            else
                error(14)
        until (sy <> ident) and not (sy in typedels);
        if fwptr <> nil then
            begin
                error(117);
                WriteLnMessage;
                repeat
                    WriteMessageLine(StringOf(' type-id ', fwptr^.name));
                    fwptr := fwptr^.next
                until fwptr = nil;
                if not eol then
                    WriteMessage(StringOf(' ' : chcnt + 16))
            end
    end; (*vardeclaration*)

end.